Исходный код

Option Explicit
Call WorkWithObjectDefsCol(ThisApplication.ObjectDefs)


'==============================================================================
' Выполнить выбранные пользователем действия над коллекцией типов объектов.
' Выполнять скрипт может только системный администратор
'==============================================================================
Sub WorkWithObjectDefsCol(ObjDefsCol)
        'Если коллекция пустая, закончить работу сразу
        If ObjDefsCol.Count=0 Then
                MsgBox "Передана пустая коллекция.", vbExclamation
                Exit Sub
        End If
        
        Dim SelDlg, RetVal, strAction, ArActions
        
        ArActions = Array("Создать тип объекта", "Удалить тип объекта")
        
        'Предоставить пользователю выбрать действие 
        Set SelDlg = ThisApplication.Dialogs.SelectDlg
        SelDlg.SelectFrom = ArActions 
        SelDlg.Prompt = "Выберите действие:"
        RetVal = SelDlg.Show
        
        'Если пользователь отменил диалог или ничего не выбрал, закончить работу.
        'Диалог вернул массив, поскольку был инициализирован строковым массивом
        If (RetVal <> TRUE) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
        
        'Выполнить все заданные действия
        For Each strAction In SelDlg.Objects
                If StrComp(strAction, ArActions(0))=0 Then
                                                                                            Call CreateObjectDef(ObjDefsCol)
                ElseIf StrComp(strAction, ArActions(1))=0 Then
                                                                                            Call RemoveObjectDef(ObjDefsCol)
                End If
        Next
End Sub
'==============================================================================


'==============================================================================
'Создать новый    тип объекта
'==============================================================================
Sub CreateObjectDef(ObjDefsCol)
        Dim StrRet, NewObjDef, NewObj, i, EditObjDlg, StrSysName 
        
        'Запросить описание нового типа
        StrRet = InputBox("Введите описание для нового типа объекта:")
        
        'Если введена пустая строка или диалог отменен, выйти из процедуры
        If StrRet="" Then Exit Sub
        
        'Проверить, существует ли такое системное имя; если да - запросить другое
        StrSysName = "TYPE_NEW"
        While ObjDefsCol.Has(StrSysName)
                    StrSysName = InputBox("Введите другое сист. имя (такое уже есть):",, StrSysName)
        Wend
                
        'Создать новый тип объекта
        Set NewObjDef = ObjDefsCol.Create
        
        'Присвоим значения некоторым свойствам
        With NewObjDef
                .Description = StrRet 'описание
                .SysName =  StrSysName  'системное имя
                .Icon = ThisApplication.Icons(0) 'присвоим иконку
                .Abstract = TRUE 'сделаем новый тип абстрактным                
        End With
        
        'Сообщить результат
        MsgBox "Новый тип объекта создан в коллекции c индексом " & ObjDefsCol.Index(NewObjDef)
End Sub
'==============================================================================


'==============================================================================
'Удалить тип объекта из коллекции
'==============================================================================
Sub RemoveObjectDef(ObjDefsCol)
        Dim StrRet, index, ODef, RetVal
        
        'Запросить индекс типа для удаления. Он не должен превышать количество 
        'типов объектов в приложении
        StrRet = InputBox("Введите индекс типа объекта, который должен быть удален:" & Chr(13) &_
                         "(от 0 до " & ObjDefsCol.Count-1 & "):")
        
        'Если введено не-число или диалог отменен, выйти из процедуры
        If (StrRet="") Or (Not IsNumeric(StrRet)) Then Exit Sub
        
        'Получить введенный индекс
        index = CLng(StrRet)
        
        'Возможно, введенное число выходит за границы допустимого диапазона
        If Not ObjDefsCol.Has(index) Then
                MsgBox "Задан недопустимый индекс.", vbExclamation
                Exit Sub
        End If
        
        'Запросить подтверждение удаления
        Set ODef = ObjDefsCol.Item(index)
        RetVal =     MsgBox("Удалить тип объекта """ & ODef.Description & """?", vbQuestion + vbYesNo)    
        
        'Попытаться удалить тип объекта
        If RetVal <> vbNo Then
                'Отключить обработку ошибок (они могут возникнуть при удалении типа)
                On Error Resume Next
                
                'Удалить тип объекта
                ObjDefsCol.Remove ODef 
                
                'Если ошибка, то скорее всего потому что в приложении уже созданы объекты этого типа
                If Err<>0 Then
                        MsgBox "Ошибка удаления типа объекта """ & ODef.Description & """" & Chr(13)_
                                    & "(возможно, в системе созданы объекты данного типа.)"_
                                    & Chr(13) &    "Код ошибки: " & Err, vbExclamation     
                End If
        End If        
End Sub
'==============================================================================